COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	PROG: SEQUENTIAL PROGRAMS
C00006 00003	ARRAY:
C00010 00004	MACRO:
C00012 00005	RPLAC: Destructive programs
C00016 00006	REENT: Program creating and manipulating re-entrant list structure
C00023 00007
C00024 ENDMK
C⊗;
;;;PROG: SEQUENTIAL PROGRAMS

(DEFPROP IMPUR
     ((REVERSE U) 
      (APP1  U V) 
      (APP2  U V)
      (ITAPPEND  U V)
      (ITAPP  U V)
      (ITAPP1 U V W)
      (PRTN  U N)
      (MAXPART W U N)
     ) SEQ-PGMS)

(DEFUN REVERSE (U) 
  (PROG (V)
    (SETQ V NIL)
  A
    (COND ((NULL U) (RETURN V)))
    (SETQ V (CONS (CAR U) V))
    (SETQ U (CDR U))
    (GO A)))

(DEFUN APP1 (U V) 
  (PROG () (RETURN (COND ((NULL U) V) (T (CONS (CAR U) (APP1 (CDR U) V)))))) )

(DEFUN APP2 (U V)
  (PROG (W)
    (COND ((NULL U) (RETURN V)))
    (SETQ W (CONS (CAR U) (APP2 (CDR U) V)))
    (RETURN W)
  ))

(DEFUN ITAPPEND (U V)
  (PROG (U1 V1 W)
    (SETQ W NIL)
    (SETQ U1 U)
    (SETQ V1 V)
  A
    (COND ((NULL U1) (GO B)))
    (SETQ W (CONS (CAR U1) W))
    (SETQ U1 (CDR U1))
    (GO A)
  B
    (COND ((NULL W) (RETURN V1)))
    (SETQ V1 (CONS (CAR W) V1))
    (SETQ W (CDR W))
    (GO B)
  ))

(DEFUN ITAPP (U V) (ITAPP1 U V NIL))
(DEFUN ITAPP1 (U V W)
  (COND ((NULL U) (COND ((NULL W) V) (T (ITAPP1 U (CONS (CAR W) V) (CDR W)))))
	(T (ITAPP (CDR U) V (CONS (CAR U) W)))))

;;; PARTN BOTTOM UP
(DEFUN PRTN (U N)
  (PROG (PL P V M)
    (COND ((AND (NULL U) (EQUAL N 0)) (RETURN (LIST NIL)))
	  ((EQUAL N 0) (RETURN NIL)) 
	  ((LESSP (LENGTH U) N) (RETURN NIL)) )
    (SETQ PL NIL)
    (SETQ P NIL)
    (SETQ V U)
    (SETQ M N)
;;; (GREATEREQP (LENGTH V) M)
;;; (EQUAL (PLUS (LENGTH P) M) N)
;;; (EQUAL (COMBINE (REVERSE (CONS V P)) U))
;;; all partitions "smaller" than P are in PL
  A
    (COND ((EQUAL M 1) 
	   (SETQ PL (CONS (REVERSE (CONS V P)) PL))
	   (GO B)) )
    (SETQ P (CONS (LIST (CAR V)) P))
    (SETQ V (CDR V))
    (SETQ M (SUB1 M))
    (GO A)
  B
    (COND ((MAXPART (CAR PL) U N) (RETURN PL))
          ((LESSP M (LENGTH V)) 
	   (SETQ P (CONS (APPEND (CAR P) (LIST (CAR V))) (CDR P)) )
	   (SETQ V (CDR V))
	   (GO A)) )
    (SETQ V (APPEND (CAR P) V))
    (SETQ P (CDR P))
    (SETQ M (ADD1 M))
    (GO B)
  ))

(DEFUN MAXPART (W U N) (LESSP (LENGTH U) (PLUS (LENGTH (CAR W))  N)) )

;;;ARRAY:

(DEFPROP IMPUR
	((PICTURE_FIND PIC PAT)
	 (PMATCH PAT PIC I J)
 	 (TEST_PICTURE_FIND )
	) ARRAY-PGMS)

(DEFUN PICTURE_FIND (PIC PAT)
   (PROG (I J M N LOCS)
    (SETQ M (SUB1 (CADR (ARRAYDIMS PIC))))
    (SETQ N (SUB1 (CADDR (ARRAYDIMS PIC))))
    (SETQ I 0)
    (SETQ J 0)
    (SETQ LOCS NIL)
  LOOP
    (COND ((PMATCH PAT PIC I J) (SETQ LOCS (CONS (CONS I J) LOCS)) ))
    (COND ((LESSP J N) (SETQ J (ADD1 J)) (GO LOOP)))
    (COND ((LESSP I M) (SETQ I (ADD1 I)) (SETQ J 0) (GO LOOP)))
    (RETURN LOCS)))



;;;A SPECIFICATION IS A LIST OF TRIPLES (ROW_DISPLACE COL_DISPLACE PREDICATE)
;;;IT MATCHES AT (PIC I J) ↔ (PRED (PIC (PLUS I RD) (PLUS J DC))) FOR ALL
;;;TRIPLES IN THE LIST

(DEFUN PMATCH (PAT PIC I J)
  (PROG (S P R C M N)
    (SETQ M (SUB1 (CADR (ARRAYDIMS PIC))))
    (SETQ N (SUB1 (CADDR (ARRAYDIMS PIC))))
    (SETQ P PAT)
LOOP
    (COND ((NULL P) (RETURN T)))
    (SETQ S (CAR P))
    (SETQ R (PLUS I (CAR S)))
    (COND ((OR (LESSP R 0)(LESSP M R)) (RETURN NIL))) ;;; OUT OF BOUNDS
    (SETQ C (PLUS J (CADR S)))
    (COND ((OR (LESSP C 0)(LESSP N C)) (RETURN NIL))) ;;; OUT OF BOUNDS
    (COND ((APPLY (CADDR S) (LIST (APPLY PIC (LIST R C)))) 
           (SETQ P (CDR P)) 
	   (GO LOOP)))
    (RETURN NIL)
))


(DEFUN TEST_PICTURE_FIND ()
  (PROG (S1 S2 S3 S5 S5 PAT)
    (ARRAY PIX T 6 6)
    (FILLARRAY 'PIX '(W R W G W B 
		      R W G W B W 
		      W G W B W R 
		      G W B W R W 
		      W B W R W G 
		      B W R W G W) )

    (SETQ S1 '(0 0 (FUNCTION (LAMBDA (X) (EQ X 'W))) ) )
    (SETQ S2 '(0 1 (FUNCTION (LAMBDA (X) (EQ X 'R))) ) )
    (SETQ S3 '(1 0 (FUNCTION (LAMBDA (X) (EQ X 'R))) ) )
    (SETQ S4 '(-1 0 (FUNCTION (LAMBDA (X) (EQ X 'B))) ) )
    (SETQ S5 '(0 -1 (FUNCTION (LAMBDA (X) (EQ X 'B))) ) )

    (SETQ PAT (LIST S1 S2 S3 S4 S5))
    (RETURN (PATTERN_FIND 'PIX PAT))
	;;;((4 . 2) (3 . 3) (2 . 4))
  ))
;;;MACRO:

(DEFPROP IMPUR
       ((BVARS MACRO)
	(BODY MACRO)
	(IF MACRO)
	(RCONS MACRO)
	(LCONS MACRO)
	(MACDEF MACRO)
	(PRUP U V) 
	((IFF A B C) MACDEF)
	((BBVARS E) MACDEF)
	((BBODY E) MACDEF)
       ) MACRO-DEFS)

(DEFUN BVARS MACRO (L)
  (LIST 'CADR (CADR L)) )

(DEFUN BODY MACRO (L)
  (LIST 'CADDR (CADR L)) )

(DEFUN IF MACRO (L)
  (LIST 'COND (LIST (CADR L) (CADDR L)) (LIST T (CADDDR L))) )

(DEFUN RCONS MACRO (L)
  (COND ((NULL (CDDR L)) (CADR L))
	(T (LIST 'CONS (CADR L) (CONS 'RCONS (CDDR L)))) ))


(DEFUN LCONS MACRO (L)
  (COND ((NULL (CDDR L)) (CADR L))
	(T (CONS 'LCONS 
	         (CONS (LIST 'CONS (CADR L) (CADDR L) ) (CDDDR L)))) ) )

(DEFUN MACDEF MACRO (L)
  (LIST 'DEFUN 
	(CAADR L)
	'MACRO 
	'(%L) 
	(LIST 'SUBLIS 
	      (LIST 'PRUP (LIST 'QUOTE (CDADR L)) (LIST 'CDR '%L) )
	      (LIST 'QUOTE (CADDR L))) ))

(DEFUN PRUP (U V) 
  (COND ((OR (NULL U) (NULL V)) NIL) 
	(T (CONS (CONS (CAR U) (CAR V)) (PRUP (CDR U) (CDR V))))))

(MACDEF (IFF A B C) (COND (A B) (T C)))
(MACDEF (BBVARS E) (CADR E))
(MACDEF (BBODY E) (CADDR E))

;;;RPLAC: Destructive programs

(DEFPROP IMPUR 
       ((NCONC U V)
	(TEST1)
	(TEST2)
	(TEST3)
	(TEST4)
	(NCONC0 U V) 
	(NCONC1 U W V) 
	(INSERTB0 U)
	(INSERTB U)
	(REMV X U)
	(PRUNE U SEEN)
	) RPLAC-PGMS)

(DEFUN TEST1 ()
  (PROG ()
    (SETQ X '(A B))
    (SETQ Y '(A B))
    (SETQ Z (RPLACA (CDR X) 'C))
  ))
;;;X←(A C) Y←(A B) Z←(C) 

(DEFUN TEST2 ()
  (PROG ()
    (SETQ X '(A B))
    (SETQ Y X)
    (SETQ Z (RPLACA (CDR X) 'C))
  ))
;;;X←(A C) Y←(A C) Z←(C) 


(DEFUN COPY (X)
  (COND ((ATOM X) X)
	(T (CONS (COPY (CAR X)) (COPY (CDR X))))))

(DEFUN TEST3 ()
  (PROG ()
    (SETQ X '(A B))
    (SETQ Y X)
    (RETURN (EQUAL X ((LAMBDA (SIDE) X)(RPLACA (CDR Y) 'C))))
  ))
;;;T
;;;A←(A C) 

(DEFUN TEST4 ()
  (PROG ()
    (SETQ X '(A B))
    (SETQ Y X)
    (RETURN (EQUAL (COPY X) ((LAMBDA (SIDE) X)(RPLACA (CDR Y) 'C))))
  ))
;;;NIL
;;;A←(A C) 

(DEFUN NCONC (U V)
  (PROG (W)
    (COND ((NULL U) (RETURN V)))
    (SETQ W U)
  LOOP
    (COND ((NULL (CDR W)) (RPLACD W V) (RETURN U)) )
    (SETQ W (CDR W))
    (GO LOOP)
  ))


(DEFUN NCONC0 (U V) (COND ((NULL U) V) (T (NCONC1 U U V)) ))

(DEFUN NCONC1 (U W V) 
  (COND ((NULL (CDR W)) ((LAMBDA (SIDE) U)(RPLACD W V)))
	(T (NCONC1 U (CDR W) V)) ))

(DEFUN INSERTB0 (U)
  (COND ((NULL U) NIL)
	((EQ (CAR U) 'A) (CONS 'A (CONS 'B (INSERTB0 (CDR U)))))
	(T (CONS (CAR U) (INSERTB0 (CDR U)))) ))


(DEFUN INSERTB (U)
  (PROG (W)
    (SETQ W U)
  LOOP
    (COND ((NULL W) (RETURN U)))
    (COND ((EQ (CAR W)) 'A) (SETQ (CDR W) (CONS 'B (CDR W)))))
    (SETQ W (CDR W))
    (GO LOOP)
  ))


;;; using rplacs to remove some atom from a list
(DEFUN REMV (X U)
  (PROG (U1)
  LU ;;; Remove leading instances of X
    (COND ((NULL U) (RETURN U)) )
    (COND ((EQ (CAR U) X) (SETQ U (CDR U)) (GO LU)))
    (SETQ U1 U)

  LU1 ;;; Remove interior instances of X
    (COND ((NULL (CDR U1)) (RETURN U)) )
    (COND ((EQ (CADR U1) X) (RPLACD U1 (CDDR U1))(GO LU1)) )
    (SETQ U1 (CDR U1))
    (GO LU1)
  ) )


;;; destructively prune members of seen from the list u
;;; by tacking on dummy, one loop will suffice
(DEFUN PRUNE (U SEEN)
  (PROG (V)
    (SETQ U (CONS NIL  U))
    (SETQ V U)
  LOOP
    (COND ((NULL (CDR V)) (RETURN (CDR U))) )
    (COND ((MEMBER (CADR V) SEEN) (SETQ (CDR V) (CDDR V)) (GO LOOP)) )
    (SETQ V (CDR V))
    (GO LOOP)
  ))
;;;REENT: Program creating and manipulating re-entrant list structure

(DEFPROP IMPUR 
       ((MKLEFT)
	(EQUIV X Y)
	(EQUIV1 X Y U) 
	(MATCH X Y U) 
	(UNMATCH X Y U) 
	(FIB N)
	(FIBON N) 
	(FIBLOOP N L)
	(LABL NAME EXP)
	(LAB X)
	(LABL_TEST)
       ) REENT-PGMS)

(DEFUN MKLEFT()
    (PROG () 
      (SETQ LEFT '(LAMBDA (X) (COND ((ATOM X) X) (T (LEFT (CAR X))) )))
      (RPLACA (CADR (CADDR (CADDR LEFT))) LEFT)
      (RETURN 'LEFT)
    ))


(DEFUN EQUIV (X Y) (NOT (EQ (EQUIV1 X Y NIL) 'LOSE)))

(DEFUN EQUIV1 (X Y U) 
       (COND ((EQ U 'LOSE) 'LOSE)
	     ((OR (EQ X Y) (MATCH X Y U)) U)
	     ((OR (ATOM X) (ATOM Y) (UNMATCH X Y U)) 'LOSE)
	     (T (EQUIV1 (CAR X)
			(CAR Y)
			(EQUIV1 (CDR X)
				(CDR Y)
				(CONS (CONS X Y) U))))))

(DEFUN MATCH (X Y U) 
       (AND (NOT (NULL U))
	    (OR (AND (EQ X (CAAR U)) (EQ Y (CDAR U)))
		(MATCH X Y (CDR U)))))

(DEFUN UNMATCH (X Y U) 
       (AND (NOT (NULL U))
	    (OR (EQ X (CAAR U))
		(EQ Y (CDAR U))
		(UNMATCH X Y (CDR U)))))


;;;learning fibonacci program
(DEFUN FIB (N)
    ((LAMBDA (FIBLIST)
	(PROG (L)
	    (COND ((OR (EQ N 0) (EQ N 1)) (RETURN 1)))
	    (SETQ L FIBLIST)
	    (PRINT FIBLIST)
	 FIBLOOP
	    (COND ((NULL (CDDR L)) 
		   (RPLACD (CDR L) (LIST (PLUS (CAR L) (CADR L))))))
	    (COND ((EQ N 2) (RETURN (CADDR L))))
	    (SETQ N (SUB1 N))
	    (SETQ L (CDR L))
	    (GO FIBLOOP) ) )
     '(1 1))
)

(DEFUN FIBON (N) 
  (COND ((OR (EQ N 0) (EQ N 1)) 1) (T (FIBLOOP N '(1 1))) ))

(DEFUN FIBLOOP (N L)
  (COND ((NULL (CDDR L))
	 (COND ((EQ N 2) (CADR (RPLACD (CDR L) (LIST (PLUS (CAR L) (CADR L))))))
	       (T (FIBLOOP (SUB1 N) (RPLACD (CDR L) (LIST (PLUS (CAR L) (CADR L)))))) ))
	(T (COND ((EQ N 2) (CADDR L))(T (FIBLOOP (SUB1 N) (CDR L))))) ))

;;; Solution to MK-LABL exercise

(DEFUN LABL (NAME EXP) (LAB (PUTPROP NAME EXP 'EXPR)))
(DEFUN LAB (X)
  (PROG NIL
    (COND ((ATOM X) (RETURN NIL)) )
    (LAB (CAR X))
    (LAB (CDR X))
    (COND ((EQ (CAR X) NAME ) (RPLACA X EXP)) )
    (COND ((EQ (CDR X) NAME ) (RPLACD X EXP)) )
    NIL
 ) )


(DEFUN LABL_TEST ()
  (PROG ()
    (LABL 'LEFT '(LAMBDA (X) (COND ((ATOM X) X) (T (LEFT (CDR X))))))
    (LABL 'FRINGE 
	  '(LAMBDA (X) 
	     (COND ((ATOM X) (NCONS X)) 
		   (T (APPEND (FRINGE (CAR X)) (FRINGE (CDR X)))) )))
  ))